//=============================================================================
///	FFI module
//=============================================================================

#include "mffi.h"
#include "sexp.h"
#include "vm.h"

#ifndef _MSC_VER
#include <alloca.h>
#else
#include <malloc.h>
#endif

#ifndef	FALSE
#define	FALSE	(0)
#define	TRUE	(1)
#endif

//=============================================================================
// DLL

#ifdef _MSC_VER
// VC
#include <windows.h>
typedef HMODULE HDLL_MODULE;

HDLL_MODULE load_dll_module(const char* module_name) {
	return LoadLibrary(module_name);
}

void free_dll_module(HDLL_MODULE hDll) {
	FreeLibrary(hDll);
}

void* get_proc_adr(HDLL_MODULE hDll, const char* proc_name) {
	return GetProcAddress(hDll, proc_name);
}

#else
// Linux
typedef void* HDLL_MODULE;

#include <dlfcn.h>

HDLL_MODULE load_dll_module(const char* module_name) {
	return dlopen(module_name, RTLD_LAZY);
}

void free_dll_module(HDLL_MODULE hDll) {
	dlclose(hDll);
}

void* get_proc_adr(HDLL_MODULE hDll, const char* proc_name) {
	return dlsym(hDll, proc_name);
}

#endif


//=============================================================================
// C-Pointer
typedef struct CPtr {
	const STypeInfo* typeinfo;
	void* ptr;
} CPtr;

static void cptr_write(SExp s, int b_escape, struct StreamBase* strm) {
	char buf[32];
	sprintf(buf, "#<cptr:%p>", S2PTR(s));
	strm_puts(strm, buf, 0);
}

const STypeInfo TCPtr = {
	"cptr",
	cptr_write,
	cant_apply,
};

static SExp gen_cptr(void* ptr) {
	CPtr* p = (CPtr*)smalloc(sizeof(*p), FALSE);
	p->typeinfo = &TCPtr;
	p->ptr = ptr;
	return ptr2s(p);
}


//=============================================================================
// bytevector
typedef struct ByteVector {
	const STypeInfo* typeinfo;
	size_t size;
	char buf[1];
} ByteVector;

static void bytevector_write(SExp s, int b_escape, struct StreamBase* strm) {
	char buf[32];
	sprintf(buf, "#<bytevector:%p>", S2PTR(s));
	strm_puts(strm, buf, 0);
}

const STypeInfo TByteVector = {
	"bytevector",
	bytevector_write,
	cant_apply,
};

static SExp gen_bytevector(size_t size) {
	ByteVector* p = (ByteVector*)smalloc(sizeof(*p) + size-1, FALSE);
	p->typeinfo = &TByteVector;
	p->size = size;
	return ptr2s(p);
}


//=============================================================================
// FFI-C-Function

typedef enum {
	eCTypeUnknown,
	eCTypeVoid,
	eCTypeInt,
	eCTypePtr,
	eCTypeString,
} eCType;

static const int CTypeSize[] = {
	0,
	0,
	sizeof(int),
	sizeof(void*),
	sizeof(char*),
};

static int get_ctype_size(eCType type) {
	return CTypeSize[type];
}

static eCType sym2ctype(SExp s) {
	if (eq(s, intern("void"))) {
		return eCTypeVoid;
	} else if (eq(s, intern("int"))) {
		return eCTypeInt;
	} else if (eq(s, intern("void*"))) {
		return eCTypePtr;
	} else if (eq(s, intern("char*"))) {
		return eCTypeString;
	} else {
		return eCTypeUnknown;
	}
}

char* s2int(char* p, SExp s) {
	const STypeInfo* i = type_of(s);
	int* q = (int*)p;
	if (i == &TFixnum) {
		*q++ = S2FIXNUM(s);
	}
	return (char*)q == p ? NULL : (char*)q;
}

char* s2ptr(char* p, SExp s) {
	const STypeInfo* i = type_of(s);
	void** q = (void**)p;
	if (i == &TCPtr) {
		*q++ = ((CPtr*)S2PTR(s))->ptr;
	} else if (i == &TByteVector) {
		*q++ = ((ByteVector*)S2PTR(s))->buf;
	} else if (eq(s, sNIL)) {
		*q++ = NULL;
	}
	return (char*)q == p ? NULL : (char*)q;
}

char* s2string(char* p, SExp s) {
	const STypeInfo* i = type_of(s);
	void** q = (void**)p;
	if (i == &TString) {
		*q++ = (void*)S2CSTR(s);
	} else if (i == &TCPtr) {
		*q++ = ((CPtr*)S2PTR(s))->ptr;
	} else if (i == &TByteVector) {
		*q++ = ((ByteVector*)S2PTR(s))->buf;
	} else if (eq(s, sNIL)) {
		*q++ = NULL;
	}
	return (char*)q == p ? NULL : (char*)q;
}

static char* s2ctype(char* p, eCType type, SExp s) {
	switch (type) {
	default:	return NULL;
	case eCTypeInt:		return s2int(p, s);
	case eCTypePtr:		return s2ptr(p, s);
	case eCTypeString:	return s2string(p, s);
	}
}

typedef struct CFunction {
	const STypeInfo* typeinfo;
	int (*cfunc)();
	eCType rettype;
	int argnum;
	int argsize;
	struct {
		eCType type;
		int size;
	} args[1];	//expand
} CFunction;

static void cfunc_write(SExp s, int b_escape, struct StreamBase* strm) {
	char buf[32];
	sprintf(buf, "#<cfunc:%p>", S2PTR(s));
	strm_puts(strm, buf, 0);
}

#ifdef _MSC_VER
#pragma runtime_checks("", off)
#endif
static SExp cfunc_apply(SExp self, int s, int argnum) {
	CFunction* p = (CFunction*)S2PTR(self);
	if (argnum != p->argnum) {
		return error("Illegal argnum");
	} else {
		char* buf = (char*)alloca(p->argsize);
		char* q = buf;
		int i;
		for (i = 0; i < argnum; ++i) {
			SExp x = vm_stack_ref(s, i);
			q = s2ctype(q, p->args[i].type, x);
			if (q == NULL) {
				return error("Illegal type");
			}
		}

		switch (p->rettype) {
		default:	return error("Illegal type");
		case eCTypeVoid:	(p->cfunc)();	return sUNDEF;
		case eCTypeInt:	{ int r = (p->cfunc)();	return fixnum2s(r); }
		case eCTypePtr:	{ void* r = ((void* (*)())p->cfunc)();	return gen_cptr(r); }
		}
	}
}
#ifdef _MSC_VER
#pragma runtime_checks("", restore)
#endif

const STypeInfo TCFunc = {
	"cfunc",
	cfunc_write,
	cfunc_apply,
};

static SExp make_cfunc(void* cfunc, SExp rettype, SExp argtypes) {
	int argnum = length(argtypes);
	CFunction* p = (CFunction*)smalloc(sizeof(*p) + sizeof(*p->args) * (argnum-1), TRUE);
	SExp q;
	int argsize = 0;
	int i;
	p->typeinfo = &TCFunc;
	p->cfunc = cfunc;
	p->rettype = sym2ctype(rettype);
	p->argnum = argnum;
	for (q = argtypes, i = 0; consp(q); q = CDR(q), ++i) {
		eCType t = sym2ctype(CAR(q));
		int size = get_ctype_size(t);
		p->args[i].type = t;
		p->args[i].size = size;
		argsize += size;
	}
	p->argsize = argsize;
	return ptr2s(p);
}


//=============================================================================
// subr
static void s_free_dll_module(SExp s) {
	CPtr* p;
	HDLL_MODULE hDll;
	s = type_check(s, &TString);
	p = (CPtr*)S2PTR(s);
	hDll = (HDLL_MODULE)p->ptr;
	free_dll_module(hDll);
	p->ptr = NULL;
}

static SExp subr_load_dll_module(int s, int argnum) {
	SExp fn = type_check(vm_stack_ref(s, 0), &TString);
	HDLL_MODULE hDll = load_dll_module(S2CSTR(fn));
	if (hDll == NULL) {
		return sFALSE;
	} else {
		SExp s = gen_cptr(hDll);
		smem_set_filnalizer(s, s_free_dll_module);
		return s;
	}
}

static SExp subr_free_dll_module(int s, int argnum) {
	SExp h = vm_stack_ref(s, 0);
	if (eq(h, sFALSE)) {
		return sFALSE;
	} else {
		s_free_dll_module(h);
		return sTRUE;
	}
}

static SExp subr_get_proc_adr(int s, int argnum) {
	SExp h = type_check(vm_stack_ref(s, 0), &TCPtr);
	SExp proc_name = type_check(vm_stack_ref(s, 1), &TString);
	HDLL_MODULE hDll = (HDLL_MODULE)((CPtr*)S2PTR(h))->ptr;
	void* proc_adr = get_proc_adr(hDll, S2CSTR(proc_name));
	if (proc_adr == NULL) {
		return sFALSE;
	} else {
		return gen_cptr(proc_adr);
	}
}

static SExp subr_make_c_function(int s, int argnum) {
	SExp ret_type = type_check(vm_stack_ref(s, 0), &TSymbol);
	SExp sproc = type_check(vm_stack_ref(s, 1), &TCPtr);
	SExp arg_types = vm_stack_ref(s, 2);
	void* proc = ((CPtr*)S2PTR(sproc))->ptr;

	return make_cfunc(proc, ret_type, arg_types);
}

static SExp subr_make_bytevector(int s, int argnum) {
	SExp size = type_check(vm_stack_ref(s, 0), &TFixnum);
	return gen_bytevector(S2FIXNUM(size));
}

static SExp subr_get_raw_value(int s, int argnum) {
	SExp buf = vm_stack_ref(s, 0);
	SFixnum ofs = S2FIXNUM(type_check(vm_stack_ref(s, 1), &TFixnum));
	SExp type = type_check(vm_stack_ref(s, 2), &TSymbol);
	char* ptr;
	if (s2ptr((char*)&ptr, buf) == NULL) {
		return error("Illegal type");
	} else {
		if (eq(type, intern("int"))) {
			return fixnum2s(*(int*)(ptr + ofs));
		} else if (eq(type, intern("int32"))) {
			return fixnum2s(*(int*)(ptr + ofs));
		} else if (eq(type, intern("int16"))) {
			return fixnum2s(*(short*)(ptr + ofs));
		} else if (eq(type, intern("int8"))) {
			return fixnum2s(*(char*)(ptr + ofs));
		} else if (eq(type, intern("uint32"))) {
			return fixnum2s(*(unsigned int*)(ptr + ofs));
		} else if (eq(type, intern("uint16"))) {
			return fixnum2s(*(unsigned short*)(ptr + ofs));
		} else if (eq(type, intern("uint8"))) {
			return fixnum2s(*(unsigned char*)(ptr + ofs));
		} else {
			return error("Illegal type");
		}
	}
}

static SExp subr_get_raw_pointer(int s, int argnum) {
	SExp buf = vm_stack_ref(s, 0);
	SFixnum ofs = S2FIXNUM(type_check(vm_stack_ref(s, 1), &TFixnum));
	char* ptr;
	if (s2ptr((char*)&ptr, buf) == NULL) {
		return error("Illegal type");
	} else {
		return gen_cptr(ptr + ofs);
	}
}

static SExp subr_set_raw_value(int s, int argnum) {
	SExp buf = vm_stack_ref(s, 0);
	SFixnum ofs = S2FIXNUM(type_check(vm_stack_ref(s, 1), &TFixnum));
	SExp type = type_check(vm_stack_ref(s, 2), &TSymbol);
	SExp value = vm_stack_ref(s, 3);
	char* ptr;
	if (s2ptr((char*)&ptr, buf) == NULL) {
		return error("Illegal type");
	} else {
		ptr += ofs;
		if (eq(type, intern("int"))) {
			*(int*)ptr = S2FIXNUM(value);
		} else if (eq(type, intern("int32"))) {
			*(int*)ptr = S2FIXNUM(value);
		} else if (eq(type, intern("int16"))) {
			*(short*)ptr = S2FIXNUM(value);
		} else if (eq(type, intern("sint8"))) {
			*(char*)ptr = S2FIXNUM(value);
		} else if (eq(type, intern("uint32"))) {
			*(unsigned int*)ptr = S2FIXNUM(value);
		} else if (eq(type, intern("uint16"))) {
			*(unsigned short*)ptr = S2FIXNUM(value);
		} else if (eq(type, intern("uint8"))) {
			*(unsigned char*)ptr = S2FIXNUM(value);
		} else if (eq(type, intern("void*"))) {
			char* val;
			if (s2ptr((char*)&val, value) == NULL) {
				error("Can't convert to ptr");
			} else {
				*(void**)ptr = val;
			}
		} else if (eq(type, intern("char*"))) {
			value = type_check(value, &TString);
			*(const char**)ptr = S2CSTR(value);
		} else {
			return error("Illegal type");
		}
		return value;
	}
}

//=============================================================================
void install_mffi(void) {
	struct {
		const char* name;
		VMFunctionType func;
		int minargnum, maxargnum;
	} static const tbl[] = {
		{	"load-dll-module",		subr_load_dll_module,		1, 1,	},
		{	"free-dll-module",		subr_free_dll_module,		1, 1,	},
		{	"get-proc-adr",			subr_get_proc_adr,			2, 2,	},

		{	"make-c-function",		subr_make_c_function,		3, 3,	},

		{	"make-bytevector",		subr_make_bytevector,		1, 1,	},
		{	"get-raw-value",		subr_get_raw_value,			3, 3,	},
		{	"set-raw-value!",		subr_set_raw_value,			4, 4,	},
		{	"get-raw-pointer",		subr_get_raw_pointer,		2, 2,	},
	};
	int i;

	for (i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
		SExp sym = intern(tbl[i].name);
		SExp func = gen_prim_func(tbl[i].func, tbl[i].minargnum, tbl[i].maxargnum, tbl[i].name);
		assign_global(sym, func);
	}
}
